{:
PURPOSE AND IMPLEMENTATION:
	This unit defines classes for writing data out to a well-formed standalone XML
  document.  These classes only support a subset of the XML 1.0 recommendation
  and have not been analyzed for conformance with the recommendation.  This
  module also only supports 8-bit character sets and makes no special allowances
  for UTF-8.

  This was written for Delphi 5.  It may work for other versions, but does
  require method overloading which was introduced in Delphi 4.

HISTORY:
	09/11/00 - Created by Colin Patrick Sarsfield

DISCLAIMER:
  Use at your own risk.

COPYRIGHT:
	Released into the public domain by Colin Sarsfield 9/13/00
}
unit XMLWriter;

interface

uses
  Classes, SysUtils;

type
  TXMLTagType = (xttStarting, xttEnding, xttStartingAndEnding, xttEndingSameLine);

  TXMLWriter = class
  private
    FCached: Boolean;
    FCache: String;
    FIndentation: Integer;
  protected
    procedure WriteBuffer(const Buffer; Count: Longint); virtual; abstract;
  public
    constructor Create(Cached: Boolean = False);
    procedure EndDoc; virtual;
    procedure StartDoc; virtual;
    procedure Write(const Value: Integer); overload;
    procedure Write(const Value: Int64); overload;
    procedure Write(const Value: Extended; Format: TFloatFormat; Precision, Digits: Integer); overload;
    procedure Write(const Value: Extended; Decimals: Integer); overload;
    procedure Write(const Value: Double; Decimals: Integer); overload;
    procedure Write(const Value: Single; Decimals: Integer); overload;
    procedure Write(const Value: String); overload;
    procedure WriteBasicData(const Name: String; const Value: String); overload;
    procedure WriteBasicData(const Name: String; const Value: Integer); overload;
    procedure WriteBasicData(const Name: String; const Value: Boolean); overload;
    procedure WriteBasicData(const Name: String; const Value: TDateTime); overload;
    procedure WriteBasicData(const Name: String; const Value: Single; const Decimals: Integer); overload;
    procedure WriteBasicData(const Name: String; StringList: TStringList); overload;
    procedure WriteStandaloneDocumentDeclaration;
    procedure WriteStr(const Value: String); virtual;
    procedure WriteTag(const Name: String; TagType: TXMLTagType = xttStarting; Open: Boolean = False);
    procedure WriteTagParam(const ParamName, Value: String); overload;
    procedure WriteTagParam(const ParamName: String; const Value: Integer); overload;
    procedure WriteTagParam(const ParamName: String; const Value: Single; const Decimals: Integer); overload;
    procedure WriteTagClose(TagType: TXMLTagType = xttStarting);
    procedure WriteLineEnd;
  end;

  TXMLStreamWriter = class(TXMLWriter)
  private
    FStream: TStream;
    FDestroyStream: Boolean;
  protected
    procedure WriteBuffer(const Buffer; Count: Longint); override;
  public
    constructor Create(AStream: TStream; Cached: Boolean = False;
        DestroyStream: Boolean = False);
    destructor Destroy; override;
  end;

  TXMLStringWriter = class(TXMLWriter)
  private
    FXMLString: String;
  protected
    procedure WriteBuffer(const Buffer; Count: Longint); override;
  public
    property XMLString: String read FXMLString;
  end;

implementation

uses
  StrLib;

{ TXMLStreamWriter }

constructor TXMLStreamWriter.Create(AStream: TStream; Cached: Boolean;
    DestroyStream: Boolean);
begin
  inherited Create(Cached);
  FDestroyStream := DestroyStream;
  FStream := AStream;
end;

destructor TXMLStreamWriter.Destroy;
begin
  if FDestroyStream then FStream.Free;
  inherited;
end;

procedure TXMLStreamWriter.WriteBuffer(const Buffer; Count: Longint);
begin
  FStream.Write(Buffer, Count);
end;

{ TXMLWriter }

procedure TXMLWriter.Write(const Value: String);
var
  ConvStr: String;
  i: Integer;
begin
  for i := 1 to Length(Value) do begin
    if Ord(Value[i]) > 127 then
      ConvStr := ConvStr + '&#' + IntToStr(Ord(Value[i])) + ';'
    else if Value[i] = '<' then
      ConvStr := ConvStr + '&lt;'
    else if Value[i] = '>' then
      ConvStr := ConvStr + '&gt;'
    else if Value[i] = '''' then
      ConvStr := ConvStr + '&apos;'
    else if Value[i] = '"' then
      ConvStr := ConvStr + '&quot;'
    else if Value[i] = '&' then
      ConvStr := ConvStr + '&amp;'
    else
      ConvStr := ConvStr + Value[i];
  end;
  WriteStr(ConvStr);
end;

procedure TXMLWriter.Write(const Value: Integer);
begin
  WriteStr(IntToStr(Value));
end;

procedure TXMLWriter.Write(const Value: Int64);
begin
  WriteStr(IntToStr(Value));
end;

procedure TXMLWriter.Write(const Value: Extended; Format: TFloatFormat;
  Precision, Digits: Integer);
begin
  WriteStr(FloatToStrF(Value, Format, Precision, Digits));
end;

procedure TXMLWriter.Write(const Value: Extended; Decimals: Integer);
begin
  Write(Value, ffFixed, 18, Decimals);
end;

procedure TXMLWriter.Write(const Value: Double; Decimals: Integer);
begin
  Write(Value, ffFixed, 15, Decimals);
end;

procedure TXMLWriter.EndDoc;
begin
  if FCached then
    WriteBuffer(FCache[1], Length(FCache));
end;

procedure TXMLWriter.StartDoc;
begin
  FCache := '';
  FIndentation := 0;
end;

procedure TXMLWriter.Write(const Value: Single; Decimals: Integer);
begin
  Write(Value, ffFixed, 7, Decimals);
end;

procedure TXMLWriter.WriteLineEnd;
var
  Str: String;
begin
  SetLength(Str, 2 + FIndentation shl 1);
  if FIndentation > 0 then
    FillChar(Str[3], FIndentation shl 1, ' ');
  Str[1] := #13;
  Str[2] := #10;
  Write(Str);
end;

procedure TXMLWriter.WriteStandaloneDocumentDeclaration;
begin
  WriteStr('<?xml version="1.0" standalone="yes"?>');
  //WriteStr('<?xml version="1.0" encoding="GB2312"?>');
end;

procedure TXMLWriter.WriteTag(const Name: String; TagType: TXMLTagType;
  Open: Boolean);
var
  Str: String;
begin
  Str := '<';
  if TagType = xttStartingAndEnding then
    WriteLineEnd
  else if TagType = xttStarting then begin
    WriteLineEnd;
    Inc(FIndentation)
  end else if TagType in [xttEnding, xttEndingSameLine] then begin
    Str := Str + '/';
    Dec(FIndentation);
    if TagType = xttEnding then
      WriteLineEnd;
  end;
  Str := Str + Name;
  WriteStr(Str);
  if not Open then
    WriteTagClose(TagType);
end;

procedure TXMLWriter.WriteTagClose(TagType: TXMLTagType);
begin
  if TagType = xttStartingAndEnding then
    WriteStr('/>')
  else
    WriteStr('>')
end;

procedure TXMLWriter.WriteStr(const Value: String);
begin
  if FCached then
    FCache := FCache + Value
  else
    WriteBuffer(Value[1], Length(Value));
end;

constructor TXMLWriter.Create(Cached: Boolean);
begin
  FCached := Cached;
end;

procedure TXMLWriter.WriteBasicData(const Name, Value: String);
begin
  //if Value = '' then Exit;  //by jamsa 20030912
  WriteTag(Name);
  Write(Value);
  WriteTag(Name, xttEndingSameLine);
end;

procedure TXMLWriter.WriteBasicData(const Name: String;
  const Value: Integer);
begin
  WriteBasicData(Name, IntToStr(Value));
end;

procedure TXMLWriter.WriteBasicData(const Name: String; StringList: TStringList);
var
  i: Integer;
begin
  if StringList.Count = 0 then Exit;
  WriteTag(Name);
  for i := 0 to Pred(StringList.Count) do
    WriteBasicData('S', StringList[i]);
  WriteTag(Name, xttEnding);
end;

procedure TXMLWriter.WriteBasicData(const Name: String;
  const Value: Boolean);
begin
  if Value then
    WriteTag(Name, xttStartingAndEnding);
end;

procedure TXMLWriter.WriteBasicData(const Name: String;
  const Value: TDateTime);
begin
  if Value <> 0 then
    WriteBasicData(Name, DateTimeToStr(Value));
end;

procedure TXMLWriter.WriteBasicData(const Name: String;
  const Value: Single; const Decimals: Integer);
begin
  WriteBasicData(Name, FloatToStrF(Value, ffFixed, 7, Decimals));
end;

procedure TXMLWriter.WriteTagParam(const ParamName: String; const Value: Single; const Decimals: Integer);
begin
  WriteTagParam(ParamName, FloatToStrF(Value, ffFixed, 7, Decimals));
end;

procedure TXMLWriter.WriteTagParam(const ParamName, Value: String);
begin
  WriteStr(' ' + ParamName + '="');
  Write(Value);
  WriteStr('"');
end;

procedure TXMLWriter.WriteTagParam(const ParamName: String; const Value: Integer);
begin
  WriteTagParam(ParamName, IntToStr(Value));
end;

{ TXMLStringWriter }

procedure TXMLStringWriter.WriteBuffer(const Buffer; Count: Integer);
begin
  FXMLString := FXMLString + Copy(PChar(@Buffer), 1, Count);
end;

end.
